home *** CD-ROM | disk | FTP | other *** search
/ Languguage OS 2 / Languguage OS II Version 10-94 (Knowledge Media)(1994).ISO / gnu / tforth21.lha / tile-forth-2.1 / lib / parser.f83 < prev    next >
Text File  |  1991-09-14  |  12KB  |  422 lines
  1. \
  2. \  TOP DOWN PARSER DEFINITIONS
  3. \
  4. \  Copyright (C) 1990 by Mikael R.K. Patel
  5. \
  6. \  Computer Aided Design Laboratory (CADLAB)
  7. \  Department of Computer and Information Science
  8. \  Linkoping University
  9. \  S-581 83 LINKOPING
  10. \  SWEDEN
  11. \
  12. \  Email: mip@ida.liu.se
  13. \
  14. \  Started on: 12 February 1990
  15. \
  16. \  Last updated on: 21 August 1990
  17. \
  18. \  Dependencies:
  19. \       (forth) forth, compiler, structures, blocks, internals
  20. \
  21. \  Description:
  22. \       Top down parser virtual machine instructions.
  23. \
  24. \  Copying:
  25. \       This program is free software; you can redistribute it and\or modify
  26. \       it under the terms of the GNU General Public License as published by
  27. \       the Free Software Foundation; either version 1, or (at your option)
  28. \       any later version.
  29. \
  30. \       This program is distributed in the hope that it will be useful,
  31. \       but WITHOUT ANY WARRANTY; without even the implied warranty of
  32. \       MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  33. \       GNU General Public License for more details.
  34. \
  35. \       You should have received a copy of the GNU General Public License
  36. \       along with this program; see the file COPYING.  If not, write to
  37. \       the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 
  38.  
  39. .( Loading Parser definitions...) cr
  40.  
  41. #include internals.f83
  42. #include structures.f83
  43. #include blocks.f83
  44.  
  45. vocabulary parser ( -- )
  46.  
  47. compiler blocks structures parser definitions
  48.  
  49. \ Grammer symbol structure
  50.  
  51. struct.type symbol ( -- ) 
  52.   ptr +entry ( symbol -- addr) private
  53.   ptr +syntax ( symbol -- addr) private
  54.   ptr +primary ( symbol -- addr) private
  55. struct.init ( symbol -- )
  56.   last over +entry !            ( Assign pointer back to entry)
  57.   nil over +syntax !            ( Initiate syntax pointer)
  58.   nil swap +primary !            ( Initiate primary pointer)
  59. struct.end
  60.  
  61. \ Grammer production structure
  62.  
  63. struct.type rule ( -- ) private
  64.   ptr +next ( rule -- addr) private
  65.   ptr +rule ( rule -- addr) private
  66. struct.end
  67.  
  68. \ Scanner buffer and break function pointer
  69.  
  70. variable buffer ( -- addr)
  71. variable >buffer ( -- addr)
  72. variable >break ( -- addr)
  73. variable >skip ( -- addr)
  74.  
  75. : skip-white-space ( addr1 -- addr2)
  76.   begin                    ( Skip blanks before symbol)
  77.     dup c@ dup                ( Fetch the character)
  78.     32 > not swap            ( Check if it is not a character)
  79.     0= not and                ( Check if it is not null)
  80.   while
  81.     1+                    ( Step to next character)
  82.   repeat
  83. ; 
  84.  
  85. ' skip-white-space >skip !        ( Assign initiate skip function)
  86.  
  87. : break-on-special ( addr1 -- bool)
  88.   c@                    ( Fetch next character)
  89.   dup ascii a ascii z ?within        ( Check if a lowercase letter)
  90.   if drop false                ( Return false)
  91.   else
  92.     dup ascii A ascii Z ?within        ( Check if a uppercase letter)
  93.     if drop false            ( Return false)
  94.     else
  95.       ascii 0 ascii 9 ?within not    ( Check if not a digit character)
  96.     then
  97.   then
  98. ; 
  99.  
  100. : break-on-white-space ( addr -- bool)
  101.   c@ 32 > not                 ( Forth word break function)
  102. ; 
  103.  
  104. ' break-on-special >break !        ( Assign initiate break function)
  105.  
  106. : scan ( -- addr n)
  107.   >buffer @                ( Start scanning in input buffer)
  108.   >skip @ execute            ( Perform skip function)
  109.   dup                    ( Save pointer to beginning)
  110.   dup >break @ execute            ( Use break function)
  111.   if dup c@                ( Check for a single break character)
  112.     if 1+ then                ( Increment to capture)
  113.   else
  114.     begin
  115.       1+                ( Increment to next character)
  116.       dup >break @ execute        ( Use break function)
  117.     until                ( Time to stop scanning)
  118.   then
  119.   dup >buffer !                ( Save pointer to next character)
  120.   over -                ( Calculate number of characters)
  121. ;
  122.  
  123. \ String matching function
  124.  
  125. #ifundef -match
  126.  
  127. : -match ( addr1 addr2 n -- bool)
  128.   ?dup                    ( Check for non zero length)
  129.   if >r                    ( Save length)
  130.     begin
  131.       over c@ over c@ =            ( Compare two character)
  132.     while
  133.       1+ swap 1+ swap            ( Move to the next characters)
  134.       r> 1- ?dup            ( Decrement length and check)
  135.       if >r                ( Save length)
  136.       else
  137.     drop drop false exit        ( Drop pointers and return equal)
  138.       then
  139.     repeat
  140.     r> drop                ( Drop length)
  141.   then
  142.   drop drop                ( Drop pointers)
  143.   true                    ( And return not equal)
  144. ; private
  145.  
  146. #then
  147.  
  148.  
  149. \ The result of a parse: list of semantic actions
  150.  
  151. 128 constant semantics-size ( -- num) private
  152. create semantics ( -- addr) private semantics-size cells allot
  153. variable >semantics ( -- addr) private
  154.  
  155. : semantic, ( addr -- )
  156.   >semantics @ !            ( Append to list of semantics)
  157.   cell >semantics +!            ( Point to next free place in list)
  158. ;
  159.  
  160. : bind ( addr -- )
  161.   ['] (literal) semantic,        ( Generate a literal for the parameter)
  162.   semantic,                ( Passed at semantic execution time)
  163. ;
  164.  
  165. \ Parser environment for seize, release and backtrack
  166.  
  167. : seize ( rule -- rule x y rule)
  168.   dup >r                ( Copy rule parameter)
  169.   >buffer @ >semantics @        ( Build backtrack environment)
  170.   r>                    ( Return copy of rule)
  171. ; private
  172.  
  173. : release ( rule x y -- )
  174.   drop drop drop            ( Drop environment frame)
  175. ; private
  176.  
  177. : backtrack ( x y  -- )
  178.   >semantics ! >buffer !        ( Restore environment frame)
  179. ; private
  180.  
  181. \ Utility function for Parser Virtual Machine Instructions
  182.  
  183. : rule ( rule -- bool)
  184.   +rule call                ( Execute rule function)
  185. ; private
  186.  
  187. : syntax ( symbol -- bool)
  188.   +syntax @ ?dup            ( Fetch syntax definition)
  189.   if                    ( If available then for all rules)
  190.     begin
  191.       ?dup                ( For all rules)
  192.     while
  193.       seize rule            ( Seize the environment. Check rule)
  194.       if release true exit then        ( If accepted then return accept)
  195.       backtrack                ( Else backtrack to latest environment)
  196.       +next @                ( And try next rule)
  197.     repeat
  198.   then
  199.   false                    ( Return reject)
  200. ; private
  201.  
  202. : primary ( symbol -- bool)
  203.   +primary @ ?dup            ( Fetch primary definition )
  204.   if call                ( If available call function)
  205.   else
  206.     false                ( Else return reject)
  207.   then
  208. ; private
  209.  
  210. \ Parser Virtual Machine Instructions
  211.  
  212. : terminal ( symbol -- [] or [false])
  213.   +entry @ +name @            ( Access name string for symbol)
  214.   scan -match                ( Scan next token and match)
  215.   if r> drop false then            ( If not equal then reject)
  216. ;
  217.  
  218. : non-terminal ( symbol -- [] or [false])
  219.   dup syntax                ( Try syntax definition)
  220.   if drop true                ( If accepted continue)
  221.   else
  222.     primary                ( If rejected try primary function)
  223.   then
  224.   not
  225.   if r> drop false then            ( If not accepted then reject)
  226. ;
  227.  
  228. : zero-or-one ( symbol -- )
  229.   dup syntax                ( Try syntax definition)
  230.   if drop                ( Drop symbol parameter)
  231.   else
  232.     primary drop            ( Try primary definition)
  233.   then                    ( Always continue)
  234. ;
  235.  
  236. : zero-or-more ( symbol -- )
  237.   begin
  238.     dup syntax                ( Try syntax definition)
  239.     if true                ( One more time)
  240.     else
  241.       dup primary            ( Try primary definition)
  242.     then
  243.     not                    ( Check for more)
  244.   until
  245.   drop                    ( Drop symbol parameter and continue)
  246. ;
  247.  
  248. : semantic ( -- true)
  249.   r> @ semantic, true            ( Append semantic function and accept)
  250. ;
  251.  
  252. : no-semantic ( -- true)
  253.   r> drop true                ( Always return accepted)
  254. ;
  255.  
  256. \ Low Level Parser Interaction
  257.  
  258. forth
  259.  
  260. : parse ( symbol -- [semantics] or [false])
  261.   buffer @ >buffer !            ( Initiate buffer pointer)
  262.   semantics >semantics !        ( And list of semantics)
  263.   syntax                ( Try syntax definition)
  264.   if ['] exit semantic,            ( If accepted the append exit)
  265.     semantics                ( And return the list of semantics)
  266.   else
  267.     false                ( Return not parsed)
  268.   then
  269. ;
  270.  
  271. : parse" ( symbol -- )
  272.   ascii " word buffer !            ( Parse the following string)
  273.   parse ?dup                ( Use the parameter symbol syntax)
  274.   if call                ( Call the semantic actions if parsed)
  275.   else
  276.     ." No parse" cr            ( Else no parse message)
  277.   then
  278. ; execution
  279.  
  280. \ High Level Interaction Top Loop
  281.  
  282. 256 constant interact-buffer-size ( -- num) private
  283. create interact-buffer ( -- addr) private interact-buffer-size allot
  284.  
  285. : interact ( symbol -- )
  286.   interact-buffer buffer !        ( Assign input buffer)
  287.   begin
  288.     interact-buffer            ( Input buffer for interact)
  289.     interact-buffer-size expect        ( Read a line to input buffer)
  290.     span @                ( Check for empty lines)
  291.     if 0 interact-buffer span @ + c!    ( Null terminal the line)
  292.       dup parse ?dup            ( Try parsing it)
  293.       if call                ( If parsed the call semantic actions)
  294.       else
  295.     buffer @ >buffer !        ( Rescan for forth to level loop)
  296.     ['] forth +name @        ( Use forth name field)
  297.     scan -match            ( Scan first token and match)
  298.     if ." No parse" cr        ( Else no parse possible)
  299.     else
  300.       drop exit            ( Drop parameter symbol and exit)
  301.     then
  302.       then
  303.     then
  304.   again
  305. ;
  306.  
  307. \ Syntax for definition of primary functions and syntax rules
  308.  
  309. : primary ( symbol -- )
  310.   here swap +primary !            ( Add primary function to symbol)
  311.   ]                    ( Start compiling primary function)
  312. ;
  313.  
  314. : end.primary ( -- )
  315.   [compile] ;                ( Stop compiling primary function)
  316. ; immediate compilation
  317.  
  318. : syntax ( symbol -- )
  319.   dup +syntax @ ?dup            ( Check if the symbol has syntax)
  320.   if swap drop                ( Append last in list of rules)
  321.     begin
  322.       dup +next @ ?dup            ( Check if this is the last rule)
  323.     while                ( If not then step to next rule)
  324.       swap drop
  325.     repeat     
  326.     here swap +next !            ( Link into list of rules)
  327.   else
  328.     here swap +syntax !            ( Add as first rule)
  329.   then
  330.   nil , ]                ( And start compiling the rule)
  331. ;
  332.  
  333. : end.syntax ( -- )
  334.   [compile] [                ( Stop compiling the rule)
  335. ; immediate compilation
  336.  
  337. \ Basic primary functions: empty, eoln, number och entry
  338.  
  339. parser
  340.  
  341. symbol empty ( -- symbol)
  342. symbol eoln ( -- symbol)
  343. symbol number ( -- symbol)
  344. symbol identifier ( -- symbol)
  345. symbol entry ( -- symbol)
  346.  
  347. empty primary ( -- true)
  348.   true                    ( Always accept)
  349. end.primary
  350.  
  351. eoln primary ( -- bool)
  352.   scan swap drop 0=            ( Scan next token and check length)
  353. end.primary
  354.  
  355. number primary ( -- bool)
  356.   scan                    ( Scan next token and check length)
  357.   if dup 0 swap                ( Convert to a number and check)
  358.     convert rot =
  359.     if drop false            ( If not a number reject)
  360.     else
  361.       bind true                ( Else bind the number and accept)
  362.     then
  363.   else
  364.     drop false                ( If no token scanned the reject)
  365.   then
  366. end.primary
  367.   
  368. identifier primary ( -- bool)
  369.   scan ?dup                ( Scan next token and check length)
  370.   if over c@ dup            ( Fetch first character and check)
  371.      ascii a ascii z ?within swap    ( A lowercase letter or)
  372.      ascii A ascii Z ?within or        ( A uppercase letter )
  373.      if swap bind bind true        ( Bind identifier string and accept)
  374.      else
  375.        drop drop false            ( Reject this parse)
  376.      then
  377.    else
  378.      drop false                ( Reject this parse. No more input)
  379.    then
  380. end.primary
  381.    
  382. parser
  383.  
  384. \ Token buffer for vocabulary lookup
  385.  
  386. 128 constant token-size ( -- num) private
  387. create token ( -- addr) token-size allot private
  388.  
  389. entry primary ( -- bool)
  390.   scan ?dup                ( Scan next token and check length)
  391.   if dup >r                ( Save length of scan string)
  392.     token swap cmove            ( Assign token string and)
  393.     0 token r> + c!            ( terminate with a null character)
  394.     token find                ( Try to locate the symbol)
  395.     if dup +code @ VOCABULARY =        ( Check if the entry is a vocabulary)
  396.       if scan 1 =            ( Scan next token and check length)
  397.     if c@ ascii : =            ( Check first character as colon)
  398.       if >break @            ( Fetch old break function)
  399.         ['] break-on-white-space    ( Use forth word break function)
  400.         >break !            ( as the scanner break function)
  401.         scan             ( Scan again for token)
  402.         rot >break !        ( Restore old break function)
  403.         ?dup            ( Check length)
  404.         if dup >r            ( Pack as a null terminated string)
  405.           token swap cmove        ( Move string)
  406.           0 token r> + c!        ( Pad with null character)
  407.           token swap lookup        ( Look for the token in the vocabulary)
  408.           if bind true exit then    ( If found then bind, accept and exit)
  409.         then
  410.         drop            ( Drop string parameter)
  411.       then
  412.     then
  413.       else
  414.     bind true exit            ( Bind symbol and accept)
  415.       then
  416.     then
  417.   then
  418.   drop false                ( If no token scanned the reject)
  419. end.primary
  420.   
  421. forth only
  422.